home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN1.LZH / BUILD.FOR < prev    next >
Text File  |  1988-02-08  |  5KB  |  184 lines
  1.       SUBROUTINE BUILD ( STR, TOP, NTOP, BOTTOM, NBOT )
  2. C*
  3. C*                  *******************************
  4. C*                  *******************************
  5. C*                  **                           **
  6. C*                  **          BUILD            **
  7. C*                  **                           **
  8. C*                  *******************************
  9. C*                  *******************************
  10. C*
  11. C*     SUBPROGRAM :
  12. C*          BUILD OUTPUT LINE
  13. C*
  14. C*     AUTHOR :
  15. C*          ART RAGOSTA
  16. C*          MS 207-5
  17. C*          AMES RESEARCH CENTER
  18. C*          MOFFETT FIELD, CA   94035
  19. C*          (415) 694-5578
  20. C*
  21. C*     PURPOSE :
  22. C*          BUILD THE STRING OF OUTPUT UNITS, CANCELLING UNITS ON TOP
  23. C*          AND BOTTOM.
  24. C*
  25. C*     INPUT ARGUMENTS :
  26. C*          TOP    - UNITS WHICH ARE IN NUMERATOR
  27. C*          NTOP   - NUMBER IN TOP
  28. C*          BOTTOM - UNITS IN DENOMINATOR
  29. C*          NBOT   - NUMBER IN BOTTOM
  30. C*
  31. C*     OUTPUT ARGUMENTS :
  32. C*          STR  - THE TOTAL STRING OF OUTPUT UNITS
  33. C*
  34. C*     INTERNAL WORK AREAS :
  35. C*          TSTR - USED TO SIMPLIFY '**N' CALCULATIONS
  36. C*
  37. C*     COMMON BLOCKS :
  38. C*          NONE
  39. C*
  40. C*     FILE REFERENCES :
  41. C*          NONE
  42. C*
  43. C*     SUBPROGRAM REFERENCES :
  44. C*          LEFT, LENGTH
  45. C*
  46. C*     ERROR PROCESSING :
  47. C*          NONE
  48. C*
  49. C*     TRANSPORTABILITY LIMITATIONS :
  50. C*          NONE
  51. C*
  52. C*     ASSUMPTIONS AND RESTRICTIONS :
  53. C*          NONE
  54. C*
  55. C*     LANGUAGE AND COMPILER :
  56. C*          ANSI FORTRAN 77
  57. C*
  58. C*     VERSION AND DATE :
  59. C*          VERSION I.0     13-SEP-85
  60. C*
  61. C*     CHANGE HISTORY :
  62. C*          13-SEP-85    INITIAL VERSION
  63. C*
  64. C***********************************************************************
  65. C*
  66.       CHARACTER *500 TSTR
  67.       CHARACTER *(*) STR
  68.       CHARACTER *6 TOP(40), BOTTOM(40), WORK
  69. C
  70.       STR = ' '
  71.       IS = 1
  72. C
  73. C --- DELETE DUPLICATE ENTRIES ON TOP AND BOTTOM
  74. C
  75.       I = 1
  76. 10    IF (NTOP .GT. 0) THEN
  77.          DO 20 J = 1, NBOT
  78.             IF (TOP(I) .EQ. BOTTOM(J)) THEN
  79.                BOTTOM(J) = BOTTOM(NBOT)
  80.                TOP(I) = TOP(NTOP)
  81.                NTOP = NTOP - 1
  82.                NBOT = NBOT - 1
  83.                IF (I .LE. NTOP) THEN
  84.                   GO TO 10
  85.                ELSE
  86.                   GO TO 30
  87.                ENDIF
  88.             ENDIF
  89. 20          CONTINUE
  90.          I = I + 1
  91.          IF (I .LE. NTOP) GO TO 10
  92.       ENDIF
  93. C
  94. C --- REPLACE MULTIPLE ENTRIES WITH '**'N, ADD TOP UNITS TO STRING
  95. C
  96. 30    I = 1
  97. 35    IF (I .LE. NTOP) THEN
  98.          STR(IS:) = TOP(I)
  99.          IS = IS + LENGTH(TOP(I))
  100.          STR(IS:IS) = '*'
  101.          IS = IS + 1
  102.          IC = 1
  103.          J = I + 1
  104. 40       IF (J .LE. NTOP) THEN
  105.             IF (TOP(I) .EQ. TOP(J)) THEN
  106.                IC = IC + 1
  107.                TOP(J) = TOP(NTOP)
  108.                NTOP = NTOP - 1
  109.                GO TO 40
  110.             ENDIF
  111.             J = J + 1
  112.             GO TO 40
  113.          ENDIF
  114. C
  115. C ----- IF THERE WERE MORE THAN ONE, REPLACE FIRST WITH **N
  116. C
  117.          IF (IC .GT. 1) THEN
  118.             WRITE(WORK,900) IC
  119.             CALL LEFT ( WORK )
  120.             TSTR = '*' // WORK(1:LENGTH(WORK)) // '*'
  121.             STR(IS:) = TSTR
  122.             IS = IS + LENGTH(TSTR)
  123.          ENDIF
  124.          I = I + 1
  125.          GO TO 35
  126.       ENDIF
  127.       IF ( NTOP .EQ. 0 ) THEN
  128.          STR = '1*'
  129.          IS = 3
  130.       ENDIF
  131. C
  132. C --- REPLACE LAST '*' WITH '/' UNLESS THERE IS NO DENOMINATOR
  133. C
  134.       IF (NBOT .LE. 0) THEN
  135.          IF (NTOP .EQ. 0) THEN
  136.             STR = 'N.D.'
  137.             RETURN
  138.          ENDIF
  139.          STR(IS-1:IS-1) = ' '
  140.       ELSE
  141.          STR(IS-1:IS-1) = '/'
  142. C
  143. C --- REPLACE MULTIPLE ENTRIES WITH '**'N, ADD BOTTOM UNITS TO STRING
  144. C
  145.          I = 1
  146. 45       IF (I .LE. NBOT) THEN
  147.             STR(IS:) = BOTTOM(I)
  148.             IS = IS + LENGTH(BOTTOM(I))
  149.             STR(IS:IS) = '*'
  150.             IS = IS + 1
  151.             IC = 1
  152.             J = I + 1
  153. 50          IF (J .LE. NBOT) THEN
  154.                IF (BOTTOM(I) .EQ. BOTTOM(J)) THEN
  155.                   IC = IC + 1
  156.                   BOTTOM(J) = BOTTOM(NBOT)
  157.                   NBOT = NBOT - 1
  158.                   GO TO 50
  159.                ENDIF
  160.                J = J + 1
  161.                GO TO 50
  162.             ENDIF
  163. C
  164. C ----- IF THERE WERE MORE THAN ONE, REPLACE FIRST WITH **N
  165. C
  166.             IF (IC .GT. 1) THEN
  167.                WRITE(WORK,900) IC
  168.                CALL LEFT ( WORK )
  169.                TSTR = '*' // WORK(1:LENGTH(WORK)) // '*'
  170.                STR(IS:) = TSTR
  171.                IS = IS + LENGTH(TSTR)
  172.             ENDIF
  173.             I = I + 1
  174.             GO TO 45
  175.          ENDIF
  176.       STR(IS-1:IS-1) = ' '
  177.       ENDIF
  178.       RETURN
  179. 900   FORMAT(I6)
  180.       END
  181. C
  182. C---END BUILD
  183. C
  184.